home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 1.iso / dist / fw_exmh.idb / usr / freeware / lib / exmh-2.5 / uri.tcl.z / uri.tcl
Text File  |  2002-07-08  |  15KB  |  486 lines
  1. # uri.tcl
  2. #
  3. # A little support for Uniform Resource Identifiers.
  4. #
  5. # martin hamilton <martin@mrrl.lut.ac.uk>
  6. # &
  7. # John Robert LoVerso <loverso@osf.org>
  8. # Toivo Pedaste <toivo@ucs.uwa.edu.au>
  9. # Fred Douglis <douglis@research.att.com>
  10.  
  11. proc URI_Init {} {
  12.     global env uri
  13.  
  14.     if [info exists uri(init)] {
  15.     return
  16.     }
  17.  
  18.     set uri(init) 1
  19.  
  20.     Preferences_Add "WWW" \
  21.       "These options control how exmh deals with Uniform Resource
  22. Identifiers, e.g. World-Wide Web URLs.  You can arrange for URLs
  23. embedded in messages to be turned into hyperlinks, and there is an
  24. option to decipher the experimental X-URL (or X-URI) header.  This may be used
  25. by the sender of a message to include contact information, such as
  26. the address of their World-Wide Web homepage.  You can add this
  27. header to your messages by editing compcomps, replcomps and so on." {
  28.     {uri(scanForXURIs) uriScanForXURIs    ON {Scan for X-URL: headers}
  29. "This tells exmh whether to look for X-URL (or X_URI) headers in messages when
  30. you read them."}
  31.     {uri(scanForURIs) uriScanForURIs    OFF {Scan for URLs in messages}
  32. "This tells exmh whether to look for URL in the bodies of messages.
  33. If you turn it on, any URLs it finds will be turned into buttons
  34. which you can click on to launch a viewer application.  NB - this can
  35. slow down message displaying somewhat."}
  36.     {uri(scanLimit) uriScanLimit    1000 {Max lines to scan for URL}
  37. "This limits the number of lines scanned for embedded URLs,
  38. which can run slowly on large messages.  Set to a number of lines,
  39. or to the keyword \"end\" to scan the whole message."}
  40.     {uri(scanSoftLimit) uriScanSoftLimit    1000 {Stop button max lines}
  41. "If the number of lines to scan is more than this soft limit, then
  42. a stop button is displayed so you can terminate URL scanning before
  43. it completes.."}
  44.     {uri(viewer)    uriViewer {CHOICE netscape Mosaic exmh webtk surfit tclcmd} {URL Viewer}
  45. "The Mosaic and netscape options attempt to connect to a running
  46. instance of these programs.  webtk and surfit are Tcl/Tk web browsers.
  47. The exmh option uses the built-in HTML viewer.
  48. The tclcmd option lets you define your
  49. own Tcl command to display the URL.  Use the variable $xuri
  50. for the URL to display."}
  51.     {uri(viewHtml)    mimeShowHtml {CHOICE inline defer external} {How to display text/html}
  52. "There are three ways to display text/html message parts:
  53. inline - display text/html directly in the message window.
  54. defer - use buttons to display in an external viewer.
  55. external - display text/html immediatly, using an external viewer."}
  56.     {uri(mosaicApp) uriMosaicApp    {Mosaic} {Mosaic program name}
  57. "This is the name of the binary program that corresponds to the
  58. Mosaic viewer option.  For example, some sites use \"xmosaic\"."}
  59.     {uri(netscapeCmd) uriNetscapeCmd    {} {Netscape command}
  60. "This is the netscape command used to contact netscape and/or start it up.
  61. The -remote openURL($xuri) is removed in order to start up netscape.
  62. Various examples might be:
  63. netscape -display :0.1 -remote openURL($xuri,new-window)
  64. /somewhere/weird/netscape -install -remote openURL($xuri,noraise)"}
  65.     {uri(tclCmd) uriTclCmd    {NetRemote $xuri} {Tcl Command to view URL}
  66. "This is the Tcl command used if you select the \"tclcmd\" browser option.
  67. The variable \$xuri gets replaced with the URL.  If you want to run
  68. an external program, use the \"exec\" Tcl command."}
  69.     {uri(logOnEnter) uriLogOnEnter    ON    {Show selected URL}
  70. "With 'Show selected URL' enabled exmh will display
  71. the coresponding URL if you move with the mouse on an
  72. activated (looks like a button) X-Face or URL in the
  73. message text.
  74. NOTE: When you change the option you have to rescan your
  75.       current message or read another one to de/active
  76.       the option."}
  77.     }
  78.     # Convert viewHtml from boolean to choice
  79.     switch $uri(viewHtml) {
  80.     1 -
  81.     0 {
  82.         set uri(viewHtml) inline
  83.     }
  84.     }
  85.     # Nuke old "other" viewer option.
  86.     if {[string compare $uri(viewer) "other"] == 0} {
  87.     set viewerApp [option get . uriViewerApp {}]
  88.     if {[string length $viewerApp]} {
  89.         set uri(viewer) tclcmd
  90.         set uri(tclCmd) "exec $viewerApp"
  91.     } else {
  92.         set uri(viewer) netscape
  93.     }
  94.     }
  95.  
  96.     if [catch {package require netscape_remote}] {
  97.     Exmh_Debug "No netscape_remote package"
  98.     } else {
  99.     Exmh_Debug "Using netscape_remote package"
  100.     }
  101.  
  102.     # Fix up netscape command from the old flags argument
  103.     set flags [option get . uriNetscapeFlags {}]
  104.     set cmd $uri(netscapeCmd)
  105.     if {[string length $cmd] && [string match *$flags* $cmd]} {
  106.     # flags already in the command
  107.     } else {
  108.     if {![regexp {^([^     ]+)[     ]?(.*)$} $cmd x program args]} {
  109.         set program netscape
  110.         set args {-remote openURL($xuri)}
  111.     }
  112.     set uri(netscapeCmd) "$program $flags $args"
  113.     }
  114. }
  115. proc Uri_ShowPart { tkw part } {
  116.     global uri
  117.     switch -- $uri(viewHtml) {
  118.     defer {
  119.         set start [$tkw index insert]
  120.         $tkw insert insert "View HTML contents with "
  121.         if {$uri(viewer) == "other"} {
  122.         $tkw insert insert $uri(viewerApp)
  123.         } else {
  124.         $tkw insert insert $uri(viewer)
  125.         }
  126.         set end [$tkw index insert]
  127.         $tkw insert insert "\n"
  128.         TextButtonRange $tkw $start $end [list Uri_ShowPartDirect $tkw $part]
  129.     }
  130.     external {
  131.         Uri_ShowPartDirect $tkw $part
  132.     }
  133.     inline -
  134.     default {
  135.         Html_MimeShow $tkw $part
  136.     }
  137.     }
  138. }
  139. proc Uri_ShowPartDirect { tkw part } {
  140.     global mimeHdr mime
  141.     set fileName $mimeHdr($part,file)
  142.     File_Delete [Env_Tmp]/exmh.[pid].html
  143.     if [catch {exec ln $fileName [Env_Tmp]/exmh.[pid].html}] {
  144.     exec cp $fileName [Env_Tmp]/exmh.[pid].html
  145.     }
  146.     set fileName [Env_Tmp]/exmh.[pid].html
  147.     Exmh_Status "HTML Load $fileName"
  148.     $tkw insert insert "Viewing HTML ...\n"
  149.     URI_StartViewer file://localhost$fileName
  150. }
  151.  
  152. proc URI_StartViewer {xuri} {
  153.     global uri auto_index
  154.  
  155.     regsub -nocase "URL:" $xuri {} xuri
  156.     string trimright $xuri "."
  157.  
  158.     if [regexp {^mailto:(.*)$} $xuri x address] {
  159.     Msg_Mailto $xuri
  160.     return
  161.     }
  162.     regsub -all {[][$\\,~ ]} $xuri {[scan \\& %c x ; format "%%%02x" $x]} xuri
  163.     set xuri [subst $xuri]
  164.     Exmh_Status "$uri(viewer) $xuri"
  165.     if [catch {
  166.     switch -- $uri(viewer) {
  167.         Mosaic    { Mosaic_Load $xuri}
  168.         netscape {
  169.         set rmtcmd $uri(netscapeCmd)
  170.         set sendargs {openURL($xuri)}
  171.         regexp {openURL\(.*\)} $rmtcmd sendargs
  172.         set sendargs [subst $sendargs]
  173.         regsub -- {-remote openURL\(.*\)} $rmtcmd {} startcmd
  174.  
  175.         Exmh_Debug rmtcmd $rmtcmd \n sendargs $sendargs \n startcmd $startcmd
  176.  
  177.         if {([info commands info-netscape] == "info-netscape") ||
  178.             [info exists auto_index(info-netscape)]} {
  179.             # Use send-netscape extension
  180.             if [llength [info-netscape list]] {
  181.             send-netscape $sendargs
  182.             } else {
  183.                 eval exec $startcmd { $xuri & }
  184.                 Exmh_Status "Starting netscape"
  185.             }
  186.         } elseif {[ catch {eval exec $rmtcmd >& /dev/null} tmp ]} {
  187.             if [catch {
  188.                 eval exec $startcmd { $xuri & }
  189.                 Exmh_Status "Starting netscape"
  190.                     } err] {
  191.             Exmh_Status "netscape: $err"
  192.             }
  193.         }
  194.         }
  195.         surfit -
  196.         webedit -
  197.         webtk {
  198.         set interps [winfo interps]
  199.         if {$uri(viewer) == "surfit" } {
  200.             set dispFunc "surfit_create_window"
  201.         } else {
  202.             set dispFunc "Url_DisplayNew"
  203.         }
  204.         set ix [lsearch -glob $interps $uri(viewer)*]
  205.         if {$ix >= 0} {
  206.             set interp [lindex $interps $ix]
  207.         } else {
  208.             Exmh_Status "$uri(viewer) is not running"
  209.             return
  210.         }
  211.         if [catch {send -async $interp [list $dispFunc $xuri]} err] { 
  212.             Exmh_Status $err
  213.         } else {
  214.             Exmh_Status "Viewing URL with $uri(viewer)"
  215.         }
  216.         }
  217.         exmh {
  218.         Html_Window $xuri
  219.         }
  220.         tclcmd {
  221.         Exmh_Debug [subst $uri(tclCmd)]
  222.         eval $uri(tclCmd)
  223.         }
  224.     }
  225.     } err] {
  226.     Exmh_Status $err
  227.     }
  228. }
  229.  
  230. proc URI_OpenSelection {} {
  231.     if [catch {selection get} xuri] {
  232.         return
  233.     }
  234.     URI_StartViewer $xuri
  235. }
  236.  
  237. proc Hook_MsgShowParseUri {msgPath hmm} {
  238.     global uri exwin mimeHdr
  239.  
  240.     foreach hdr {x-uri x-url} {
  241.     if {[info exists mimeHdr(0=1,hdr,$hdr)] && $uri(scanForXURIs)} {
  242.         set temp_uri [MsgParseFrom $mimeHdr(0=1,hdr,$hdr) noaddr]
  243.     }
  244.     }
  245.     if [info exists temp_uri] {
  246.         regsub -all "\[ \t\n\]" $temp_uri {} temp_uri
  247.     set but [Faces_Button [list URI_StartViewer $temp_uri]]
  248.     global exmh
  249.     $but config -bitmap @$exmh(library)/url.bitmap
  250.         if $uri(logOnEnter) {
  251.         regsub -all % $temp_uri %% temp_uri
  252.         bind $but <Enter> [list Exmh_Status "X-URL:\t$temp_uri"]
  253.         bind $but <Leave> [list Exmh_Status "\t$temp_uri"]
  254.     }
  255.     } else {
  256.     Uri_ClearCurrent
  257.     }
  258.  
  259.     if !$uri(scanForURIs) {
  260.         return
  261.     }
  262.     URI_ScanMsg $exwin(mtext) $uri(scanLimit)
  263. }
  264. proc Uri_ClearCurrent {} {
  265.     Faces_ClearButton
  266. }
  267.  
  268. proc Hook_MsgClipParseUri {msgPath t} {
  269.     global uri exwin
  270.  
  271.     if !$uri(scanForURIs) {
  272.         return
  273.     }
  274.     URI_ScanMsg $t $uri(scanLimit)
  275. }
  276.  
  277. proc URI_ActiveText { w start end URI} {
  278.     global uri
  279.     # Spaces are optional around the edges of the URI in the <a href> context
  280.     set URI [string trim $URI]
  281.     # quote percents in URLs because they appear in binding commands
  282.     regsub -all % $URI %% URI
  283.     set id [TextButtonRange $w $start $end [list URI_StartViewer $URI]]
  284.     if $uri(logOnEnter) {
  285.     $w tag bind $id <Any-Enter> [list +Exmh_Status "X-URL:\t$URI"]
  286.     $w tag bind $id <Any-Leave> [list +Exmh_Status "\t$URI"]
  287.     }
  288.     update idletasks
  289.     return $id
  290. }
  291.  
  292. proc URI_ScanMsg { {w {}} {limit end} } {
  293.     global uri exwin
  294.     if {$w == {}} {
  295.     set w $exwin(mtext)
  296.     }
  297.     set x [lindex [$w config -cursor] 4]
  298.     $w config -cursor watch
  299.  
  300.     set grab 0
  301.     set uri(stop) 0
  302.     scan [$w index end] %d lnum
  303.     set limit [string trim $limit]
  304.     if {$limit != "end"} {
  305.     if {$limit > $lnum} {
  306.         set limit $lnum.0
  307.     } else {
  308.         set limit $limit.0
  309.     }
  310.     }
  311.     if {$lnum > $uri(scanSoftLimit) && ($uri(scanSoftLimit) < $limit)} {
  312.     set g $w.ustop
  313.     if [winfo exists $g] {
  314.          destroy $g
  315.     }
  316.     frame $g -bd 4 -relief raised
  317.     set f [frame $g.pad -bd 20]
  318.     set msg [Widget_Message $f msg -text "$lnum Lines to scan" -aspect 1000]
  319.     Widget_AddBut $f stop STOP {set uri(stop) 1}  {top padx 2 pady 2 filly}
  320.     bind $f.stop <Any-Key> {set uri(stop) 1 ; Exmh_Status Stop warn}
  321.     bind $g <Destroy> {set uri(stop) 1 ; Exmh_Status Stop warn}
  322.     pack $f
  323.     Widget_PlaceDialog $w $g
  324.     Visibility_Wait $f.stop
  325.     catch {
  326.         focus $f.stop
  327.         grab $f.stop
  328.     }
  329.     set grab 1
  330.     }
  331.     Exmh_Debug "URI_ScanMsg $limit"
  332.     set multiline 0
  333.     set hit 0
  334.     set protocol (ftp|http|https|gopher|nntp|telnet|wais|file|prospero|finger|urn|mailto|news|solo|x500)
  335.     # the following pattern runs extremely slowly if there are long,
  336.     # unbroken character sequences in a message.
  337. #    set protocol {[A-Za-z_]+[-A-Za-z0-9_]*}
  338.  
  339.     for {set i 0} {[$w compare $i.0 < $limit]} {if {! $hit} {incr i}} {
  340.     if {! $hit} {
  341.         set begin 0
  342.         set text [$w get $i.0 "$i.0 lineend"]
  343.     } else {
  344.         # Look for more on the same line
  345.         set text [string range $text $begin end]
  346.     }
  347.     set hit 0
  348.  
  349.     if {$grab && $i && (($i % 20) == 0)} {
  350.         $msg config -text "Scanned $i of $lnum"
  351.         update
  352.     }
  353.     if {$uri(stop)} {
  354.         break
  355.     }
  356.     ######
  357.     # In this loop $i is the current line,
  358.     # $text is the remaining part of the line
  359.     # $begin is the offset of $text within the line
  360.     #
  361.  
  362.         #######
  363.         # match URIs continued from the previous line (begin is zero)
  364.         if $multiline {
  365.             set right [string first ">" $text]
  366.             if {$right != -1} {
  367.         Exmh_Debug Regexp0 right=$right begin=$begin
  368.                 set last $i.$right
  369.                 regsub -all "\n" [$w get $mstart $last] {} temp_uri
  370.  
  371.         URI_ActiveText $w $mstart $last $temp_uri
  372.  
  373.                 set begin $right
  374.         set text [string range $text $right end]
  375.             set multiline 0
  376.         set hit 1
  377.             }
  378.         # note: we will continue to look until a close is found
  379.         continue
  380.         }
  381.  
  382.     # Each regexp clause must set:
  383.     # hit to 1 if it matched
  384.     # start to the index within the text line to begin highlight
  385.     # end to end index within the text line to end highlight
  386.     # temp_uri to the value of the URL.
  387.  
  388.     if {[regexp -indices "<$protocol:\[^>)\]+>" $text indices] == 1} {
  389.  
  390.         # check for URIs like <protocol: > present
  391.         Exmh_Debug Regexp1 $indices
  392.         set start [expr [lindex $indices 0] + 1]
  393.         set end [expr [lindex $indices 1] -1]
  394.         set hit 1
  395.  
  396.     } elseif {[regexp -indices -nocase {<a href=([^>]+)>([^<]*)(</a>)?} \
  397.         $text indices i1 i2] == 1} {
  398.  
  399.         # match real HTML links
  400.         Exmh_Debug Regexp2 $indices $i1 $i2
  401.         set temp_uri [string trim [string range $text [lindex $i1 0] [lindex $i1 1]] {"}]
  402.         set text [string range $text [lindex $indices 1] end]
  403.  
  404.         $w configure -state normal
  405.  
  406.         $w delete $i.[expr $begin + [lindex $i2 1] + 1] \
  407.             $i.[expr $begin + [lindex $indices 1] + 1]
  408.         $w delete $i.[expr $begin + [lindex $indices 0]] \
  409.             $i.[expr $begin + [lindex $i2 0]]
  410.  
  411.         $w configure -state disabled
  412.  
  413.         set start [expr $begin + [lindex $indices 0]]
  414.         set end [expr $begin + [lindex $indices 0] + [lindex $i2 1] - [lindex $i2 0] + 1]
  415.         URI_ActiveText $w $i.$start $i.$end $temp_uri
  416.  
  417.             set begin $end
  418.         set hit 1
  419.  
  420.         # Continue because we have set up begin and text properly
  421.         continue
  422.  
  423.         } elseif {[regexp -indices -nocase "<(urn|url|uri)\[: \]\[^>\]+>" $text indices] == 1} {
  424.         # match URIs wholly contained on one line
  425.         Exmh_Debug Regexp3 $indices
  426.             set start [expr [lindex $indices 0] + 1]
  427.             set end [expr [lindex $indices 1] - 1]
  428.         set hit 1
  429.  
  430.         } elseif {[regexp -indices "$protocol:/+\[^ \n\t\]+\[^ \n\t,\.\)>\'\"\]" \
  431.         $text indices] == 1} {
  432.         # check for unencapsulated URIs by protocol if no < > present
  433.         Exmh_Debug Regexp4 $indices
  434.             set start [lindex $indices 0]
  435.             set end [lindex $indices 1]
  436.         set hit 1
  437.  
  438.     } elseif {[regexp -indices -nocase \
  439.      "(urn|mailto|news|solo|x500):\[^ \n\t\)\]*\[^ \n\r\)\.\]" \
  440.                $text indices] == 1} {
  441.         Exmh_Debug Regexp5 $indices
  442.             set start [lindex $indices 0]
  443.             set end [lindex $indices 1]
  444.         set hit 1
  445.  
  446.         } elseif {[regexp -indices -nocase "<(urn|url|uri)\[: \]" $text indices] == 1} {
  447.         # match the start of a URI which is broken over more than one line
  448.         # must include <URN or <URL
  449.         Exmh_Debug Regexp6 $indices
  450.             set mstart $i.[expr [lindex $indices 0] + $begin + 1]
  451.             set multiline 1
  452.         }
  453.         if {$hit} {
  454.         # Found a URL - handle the offset between $text and the text widget line
  455.             set temp_uri [string range $text $start $end]
  456.         URI_ActiveText $w $i.[expr $begin+$start] $i.[expr $begin+$end] $temp_uri
  457.         set begin [expr $begin + $end]
  458.         set text [string range $text $end end]
  459.     }
  460.      }
  461.     if {$grab} {
  462.     catch {grab release $g.stop}
  463.     Exmh_Focus
  464.     destroy $g
  465.     }
  466.  
  467.      $w config -cursor $x
  468.  }
  469.  
  470. proc Mime_ShowUri {tkw part} {
  471.     global mimeHdr mime miscRE
  472.  
  473.     MimeWithDisplayHiding $tkw $part {
  474.     set subtype [file tail $mimeHdr($part,type)]
  475.     Mime_WithTextFile fileIO $tkw $part {
  476.         set url [read $fileIO]
  477.         set start [$tkw index insert]
  478.         $tkw insert insert $url
  479.         set end [$tkw index insert]
  480.         $tkw insert insert \n
  481.         URI_ActiveText $tkw $start $end $url
  482.     }
  483.     }
  484.     return 1
  485. }
  486.